perm filename PLTCMX.F4[MSS,LCS]1 blob
sn#077144 filedate 1974-03-19 generic text, type T, neo UTF8
00100 C**** PLTCMD, FILLER, NNN, UNPACK, ROFF ********
38800 SUBROUTINE PLTCMD
38900 CC IMPLICIT INTEGER(A-Q,S-Z)
39000 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
39100 DIMENSION NMS(8),RMOV1(8),RMOV2(8)
39200 COMMON /DL/X22,SAVER,NAME /ALF/INP(3),ML
39400 COMMON RJB,JE,CENTR,JB,RJQ(20),JQ(20)
39700 EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
39800 1,(RJC,RJQ(1)),(I2,INP(2)),(RJH,RJQ(6)),(I3,INP(3))
39950 F78F(1)='(78F)'
39960 FA5(1)='(A5) '
39970 FA1(1)='(A1) '
40000
40100 IF(I2.NE.'X')GO TO 1
40150 CC ML=' '
40200 I2=0
40300 RXC=0
40400 RMOV1(1)='Y'
40500 NAME=0
40600 14 KA=0
40700 3 KA=KA+1
40710 CC IF(ML.EQ.' ')GO TO 15
40715 IF(ML.EQ.0)GO TO 15
40720 K=K-2
40725 ML=ML-1
40730 IF(ML.EQ.0)GO TO 10
40740 GO TO 31
40800 15 TYPE 2,KA
40900 ACCEPT 11,K,ML
40950 C TYPE LAST NAME, NUMBER FOR A SERIES
41000 50 IF(K.EQ.' ')GO TO 10
41100 IF(K.EQ.'99')GO TO 140
41200 C 99=BACKUP
41300 31 IF(LOOKD(K))GO TO 56
41400 C JUMP IF FILE FOUND
41500 TYPE 55
41600 GO TO 15
41700 55 FORMAT(' FILE NOT FOUND'/)
41750 11 FORMAT(A5,I)
41800 56 NMS(KA)=K
41810 CC IF(ML.EQ.' ')GO TO 5
41820 IF(ML.EQ.0)GO TO 5
41855 RJH='Y'
41877 GO TO 21
41900 5 TYPE 8
42000 ACCEPT FA5,RJH
42100 IF(RJH.EQ.'99')GO TO 15
42200 IF(RJH.NE.'Y')RJH=0
42300 IF(RJH.EQ.0)REREAD F78F,RJH
42400 C MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
42500 21 RMOV1(KA+1)=RJH
42600 RMOV2(KA)=RJH
42700 GO TO 3
42800 140 KA=KA-1
42900 GO TO 15
43000
43100 10 KB=KA-1
43110 IF(I3.NE.'G')GO TO 22
43120 RSIZ=1
43130 GO TO 222
43200 22 TYPE 9
43300 ACCEPT F78F,RSIZ
43400 IF(RSIZ.EQ.99.OR.RSIZ.EQ.0)GO TO 5
43500 222 KA=0
43600
43700 1 IF(NAME.NE.0)GO TO 12
43800 IF(KA.EQ.KB)CALL PLOT(0,0,99)
43900 NAME=NMS(KA+1)
44000 TYPE 111,NAME
44100 RETURN
44200 12 KA=KA+1
44300 NAME=0
44400 RJD=1
44500 IF(INP(3).EQ.'C')RJD=0
44600 C 'PXC' = CALCOMP OUTPUT
44700 RJH=0
44800 RJB=RSIZ
44900 RJC=RSIZ
45000 RJG=0
45100 RJE=1
45200 RJF=1
45300 IF(RMOV2(KA).NE.'Y')RJG=RMOV2(KA)
45400 IF(RMOV1(KA).NE.0)RJE=0
45500 IF(RMOV2(KA).NE.0.OR.RJG.NE.0)RJF=0
45600 2 FORMAT(' TYPE FILE NAME',I2,1X$)
45700 8 FORMAT(' MOVE UP AT END? ',$)
45800 9 FORMAT(' SIZE FACTOR? ',$)
45900 111 FORMAT(1XA5/)
46000 END
47000 SUBROUTINE FILLER(IFILL,QJB,QCENT,BX,BY)
47100 DIMENSION IFILL(1)
47200 COMMON /DL/IXRX,SAVER,NAME
47300 COMMON /SIZ/RSZ,JCEN,KCEN
47400 COMMON /FL/IC,N,NQ,RZ,XGP
47500 COMMON /STF/RSTFAC(8),RSTJC
47600 COMMON /PLTR/IPLT,RHT,DIS
47700 COMMON/DPY/IGO,RXGP,ITOP,IBOT
48000 PX=1
48100 IF(BX.EQ.0)BX=1
48200 IF(BY.EQ.0)BY=1
48300 IF(BX)PX=-1
48400 IXGP=XGP
48500 RSI=RSTJC*BY
48600 C RI IS INVERSION FACTOR
48700 BZ=BY/BX
48800 RT=RSTJC*BX
48900 C RS=HORIZ. RT=VERT.
49000 JXGP=RXGP
49100 NX=2
49200 C NX IS POINTER IN X ARRAY
49300 ID=IFILL(NX)
49400 IF(IPLT)GO TO 101
49500 RBZ=QJB*RSZ
49600 RXX=RSZ*RT
49700 C WHAT ABOUT RXX????????
49800 RYX=QCENT*RSZ
49900 RXY=RSI*RSZ
50000 GO TO 100
50100 101 RXX=RT*DIS
50200 RXY=RSI*RHT
50300 RBZ=QJB*DIS
50400 RYX=QCENT*RHT
50500 100 RM=-1000
50600 IF(PX)RM=-RM
50700 I=NX+1
50800 103 CALL UNPACK(IA,IB,IFILL(I))
50900 IF(IA.NE.IFILL(I+1)/10000)GO TO 102
51000 I=I+1
51100 GO TO 103
51200 102 G=IA*RT+QJB
51300 H=IB*RSI+QCENT
51400 IF(IPLT)GO TO 200
51500 CALL LINES(G,H,3)
51600 GO TO 300
51700 200 IF(IXRX.EQ.0)GO TO 90
51800 M=ROFF(-H*RHT+RXGP)
51900 N=ROFF(G*DIS+XGP)
52000 GO TO 80
52100 90 M=ROFF(G*DIS)
52200 N=ROFF(H*RHT)
52300 80 CALL PLOT(M,N,3)
52400 300 NN=ID-1
52500 C LAST OF ARRAY-1
52600 P=IA*RXX
52700 CALL UNPACK(IG,H,IFILL(I+1))
52800 RB=IG*RXX+PX
52900 J=1
53000 1 JJ=1
53100 IF(PX)GO TO 30
53200 IF(RM.GT.RB)GO TO 13
53300 GO TO 31
53400 30 IF(RM.LT.RB)GO TO 13
53500 31 IF(J)GO TO 2
53600 3 CALL NNN(NN,1,0,IFILL)
53700 C FINDS BOTTOM POINTER
53800 GO TO 16
53900 2 CALL NNN(I,0,1,IFILL)
54000 C FINDS TOP POINTER(I)
54100 16 CALL UNPACK(JAX,JB,IFILL(N))
54200 CALL UNPACK(JG,JH,IFILL(N+1))
54300 CALL UNPACK(IQ,H,IFILL(NQ))
54400 RZ=RZ*RXX
54500 10 RDIS=JAX-JG
54600 IF(PX)GO TO 32
54700 IF(P.GT.RZ)P=RZ
54800 GO TO 33
54900 32 IF(P.LT.RZ)P=RZ
55000 C REVERSES VERT.
55100 33 Q=IQ*RXX
55200 C=IC*RXY+RYX
55300 IF(RDIS.NE.0)GO TO 6
55400 C FOR STRAIIGHT UP-DOWN LINES
55500 IF(NN-1.EQ.I)GO TO 13
55600 P=P-PX
55700 GO TO 5
55800 6 H=BZ*(JB-JH)/RDIS
55900 11 HH=(P-Q)*H+C
56000 PP=P+RBZ
56100 IH=ROFF(HH)
56200 IP=ROFF(PP)
56300 C ROFF IS FOR ROUND-OFF ERRORS
56400 IF(IP.EQ.MP.AND.IH.EQ.MH)GO TO 180
56500 MP=IP
56600 MH=IH
56700 C OMITS REPEATED POINTS
56800 IF(IPLT)GO TO 17
56900 CC IF(RSZ.LE.0.8571)GO TO 34
57000 CC IP=IP-JCEN
57100 CC IH=IH-KCEN
57200 CC34 CALL AVECT(IP,IH)
57300 CALL LINES(PP/RSZ,HH/RSZ,2)
57400 GO TO 180
57500 17 IF(IXRX.EQ.0)GO TO 19
57600 K=IP
57700 IP=-IH+JXGP
57800 C NO RNDOFF OR DIS-RHT FACTORS HERE YET.
57900 IH=K+IXGP
58000 19 CALL PLOT(IP,IH,2)
58100 180 JJ=JJ-1
58200 IF(JJ)GO TO 12
58300 RM=P
58400 P=P+PX
58500 IF(PX)GO TO 35
58600 IF(P.LT.RZ)GO TO 11
58700 GO TO 5
58800 35 IF(P.GT.RZ)GO TO 11
58900 5 IF(J)GO TO 4
59000 NN=NN-1
59100 IF(I.GT.NN)GO TO 13
59200 GO TO 3
59300 4 I=I+1
59400 IF(I.GT.NN)GO TO 13
59500 402 CALL UNPACK(IA,IB,IFILL(I+1))
59600 RB=IA*RXX+PX
59700 GO TO 2
59800 12 J=-J
59900 GO TO 1
60000 13 NX=ID+1
60100 IF(ID.EQ.IFILL(1))GO TO 130
60200 ID=IFILL(NX)
60300 GO TO 100
60400 130 MP=1000
60500 MH=1000
60600 RETURN
60700 END
60800
60900 SUBROUTINE NNN(J,L,K,IFILL)
61000 COMMON /FL/IC,N,NQ,RZ,XGP
61100 DIMENSION IFILL(1)
61200 CALL UNPACK(IZ,IC,IFILL(J+K))
61300 CALL UNPACK(N,IC,IFILL(J+L))
61400 N=J
61500 C C IS THE CONSTANT
61600 NQ=N+L
61700 RZ=IZ
61800 RETURN
61900 END
62000
62100 SUBROUTINE UNPACK(M,N,I)
62200 COMMON/LL/L
62300 C L IS FOR VIS. OR INVIS. LINES.
62400 N=I
62500 L=2
62600 IF(N.LT.100000000)GO TO 2
62700 L=3
62800 N=N-100000000
62900 2 M=N/10000
63000 N=N-M*10000
63100 IF(M.GT.1000)M=1000-M
63200 IF(N.GT.1000)N=1000-N
63300 RETURN
63400 END
63500
63600 FUNCTION ROFF(R)
63700 S=.5
63800 IF(R)S=-S
63900 ROFF=R+S
64000 RETURN
64100 END